home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_nn-tk.idb / usr / freeware / lib / nn / tcl / ballonhelp.tcl.z / ballonhelp.tcl
Encoding:
Tcl/Tk script  |  1999-04-16  |  4.8 KB  |  207 lines
  1. #!/usr/local/bin/wish -f
  2. #    Simple Balloon Help Package by
  3. #    Robin Becker    robin@jessikat.demon.co.uk
  4. #    Stewart Inglis    singlis@lucy.cs.waikato.ac.nz Fri Apr  4 08:57:43 1997
  5. #    This is version 0.1
  6. #       Modified Toivo Pedaste
  7. #
  8. #    Array indeces
  9. #    a    appearances -1 for ever, 0 never, >0 a times
  10. #    d    delay
  11. #    k    kill delay
  12. #    p,w    pending for widget w
  13. #    a,w    appearances for widget w
  14. #    k,w    auto kill time for widget w
  15. #    m,w    the message for widget w
  16. #    K,w    possible hanging kill after id
  17. #    c    foreground
  18. #    b    background
  19.  
  20. global balloon_v tcl_platform
  21. set balloon_v(c) black
  22. set balloon_v(b) #fffffa9fbdb1
  23.  
  24. set DEBUG 0
  25.  
  26. proc balloonHelp {w m args} {
  27.     global balloon_v DEBUG Config
  28.  
  29.     if { $DEBUG } {
  30.     puts "balloonHelp $w $m $args"
  31.     }
  32.     set balloon_v(cnt,$w) 0
  33.     foreach { i v } $args  {
  34.     switch -glob -- $i \
  35.         -d* { set balloon_v(d,$w) $v } \
  36.         -k* { set balloon_v(k,$w) $v } \
  37.         -a* { set balloon_v(a,$w) $v } \
  38.         default { error "bad args to balloonHelp" }
  39.     }
  40.     set balloon_v(m,$w) "$m"
  41.     if {[string length $m] > 60} {
  42.     set balloon_v(k,$w) [expr $Config(balloon_destroy_delay)*2]
  43.     }
  44.     set b [bind $w <Any-Enter>]
  45.     if {![regexp "balloonHelp_show $w " $b]} {
  46.     if {$b == ""} {
  47.         set b [bind [winfo class $w] <Any-Enter>]
  48.     }
  49.     if {"$b"!=""} {
  50.         set b "; $b"
  51.     }
  52.     bind $w <Any-Enter> "balloonHelp_show $w %W$b"
  53.     }
  54.     set b [bind $w <Any-Leave>]
  55.     if {![regexp "balloonHelp_kill $w " $b]} {
  56.     if {$b == ""} {
  57.         set b [bind [winfo class $w] <Any-Leave>]
  58.     }
  59.     if {"$b"!=""} {
  60.         set b "; $b"
  61.     }
  62.     bind $w <Any-Leave> "balloonHelp_kill $w 1 %W$b"
  63.     }
  64. }
  65.  
  66. proc balloonHelp_show {w W} {
  67.     global balloon_v DEBUG Config TConfig
  68.     if { $DEBUG } {
  69.     puts "balloonHelp_show $w $W"
  70.     }
  71.     if {"$w"=="$W"} {
  72.     catch { after cancel $balloon_v(K,$w);unset balloon_v(K,$w) }
  73.     catch { after cancel $balloon_v(p,$w);unset balloon_v(p,$w) }
  74.     if {[info exists balloon_v(a,$w)]} {
  75.         set a $balloon_v(a,$w)
  76.     } else {
  77.         set a $Config(balloon_number)
  78.     }
  79.     if {$TConfig(balloon_on) != 0 &&
  80.             ($balloon_v(cnt,$w) <= $a || $a == -1)} {
  81.         if {[info exists balloon_v(d,$w)]} {
  82.         set d $balloon_v(d,$w)
  83.         } else {
  84.         set d $Config(balloon_start_delay)
  85.         }
  86.         if {[info exists balloon_v(k,$w)]} {
  87.         set k $balloon_v(k,$w)
  88.         } else {
  89.         set k $Config(balloon_destroy_delay)
  90.         }
  91.         if {[info exists balloon_v(0)]} {
  92.         set d 0
  93.         set balloon_v(p,$w) 0
  94.         balloonHelp_show2 $w
  95.         } \
  96.         else {
  97.             set balloon_v(p,$w) [after $d "balloonHelp_show2 $w"]
  98.         }
  99.         set balloon_v(K,$w) [after [expr $d + $k] "balloonHelp_kill $w 0 $w"]
  100.     }
  101.     }
  102. }
  103.  
  104. proc balloonHelp_show2 {w} {
  105.     global balloon_v DEBUG
  106.     if { $DEBUG } {
  107.     puts "balloonHelp_show2 $w"
  108.     }
  109.     if {![info exists balloon_v(p,$w)]} return
  110.     unset balloon_v(p,$w)
  111.     catch    {
  112.     set X [winfo rootx $w]
  113.     set x [expr $X + [winfo width $w] -5]
  114.     set Y [winfo rooty $w]
  115.     set y [expr $Y + [winfo height $w]]
  116.     balloonHelp_root $w
  117.  
  118.     toplevel $r -relief ridge -borderwidth 2 
  119.     wm overrideredirect $r 1
  120.     wm geometry $r +${x}+${y}
  121.     pack [message $r.m -bg $balloon_v(b) -fg $balloon_v(c) -text "$balloon_v(m,$w)" -aspect 800]
  122.     catch    {
  123.         tkwait vis $r
  124.         set ya [winfo rooty $r]
  125.         set yb [winfo height $r]
  126.         set g 0
  127.         if { [expr $ya+$yb] > [winfo screenheight $w] } {
  128.         set g 1
  129.         set y [expr $Y-$yb]
  130.         }
  131.         set xa [winfo rootx $r]
  132.         set xb [winfo width $r]
  133.         set xdiff [expr $xa + $xb - [winfo screenwidth $w]]
  134.         if {$xdiff > 0} {
  135.         set g 1
  136.         set x [expr $x - $xdiff]
  137.         }
  138.         if { $x < 0 } {
  139.         set g 1
  140.         set x 0
  141.         }
  142.         if { $g == 1 } {
  143.         wm geometry $r +${x}+${y}
  144.         }
  145.         balloonHelp_delay
  146.     }
  147.     incr balloon_v(cnt,$w)
  148.     }
  149. }
  150.  
  151. proc balloonHelp_delay {} {
  152.     global balloon_v DEBUG
  153.     if { $DEBUG } {
  154.     puts "balloonHelp_delay"
  155.     }
  156.     catch { after cancel $balloon_v(0);unset balloon_v(0) }
  157. }
  158.  
  159. proc balloonHelp_kill {w m W} {
  160.     global balloon_v DEBUG
  161.     if { $DEBUG } {
  162.     puts "balloonHelp_kill $w $m $W"
  163.     }
  164.     if {"$w"=="$W"} {
  165.     catch { after cancel $balloon_v(K,$w);unset balloon_v(K,$w) }
  166.     catch { after cancel $balloon_v(p,$w);unset balloon_v(p,$w) }
  167.     balloonHelp_root $w
  168.     balloonHelp_delay
  169.     if {[winfo exists $r]} {
  170.         catch {destroy $r}
  171.         update idletasks
  172.         if {$m} {
  173.         set balloon_v(0) [after 2000 balloonHelp_delay]
  174.         }
  175.     }
  176.     }
  177. }
  178.  
  179. proc balloonHelp_hide {w} {
  180.     global balloon_v DEBUG
  181.     if { $DEBUG } {
  182.     puts "balloonHelp_hide $w"
  183.     }
  184.     balloonHelp_root $w
  185.     catch {unset balloon_v(p,$w) }
  186.     catch {wm withdraw $r; update idletasks; destroy $r; update idletasks}
  187. }
  188.  
  189. proc balloonHelp_root { w } {
  190.     if { "$w" == "." } { set w {} }
  191.     uplevel 1 set r $w.balloon
  192. }
  193.  
  194. proc balloonHelp_traverse {w} {
  195. #    puts $w
  196.     set mess [option get $w bh {}]
  197.     regsub -all {\\n} $mess "\n" mess
  198.     if {$mess != ""} {
  199.     balloonHelp $w $mess
  200.     }
  201.     foreach i [winfo children $w] {
  202.     balloonHelp_traverse $i
  203.     }
  204. }
  205.  
  206. package provide balloonHelp 0.1
  207.